*****************************************************************************
*****************************************************************************
** These are the modifications to the template which allows the correct
** parameters to be passed to VARFUNS.TLB's function:
**       build_row_display_xpr.
** The modification was necessary for long strings which must be split for
** Clipper users, which must contain the correct quotation marks.  This
** Modification uses a variable "rowdispxpr_Q" to build the row expression
** parameter which is placed in quotes and passed to PICKDRVR.PRG.
** This only affects long "rowdispxpr's" which require splitting.

** Modification 1): Line 54
** Modification 2): Line 138
** Modification 3): Line 360
** (John McCarvel 6-13-89)
******************************************************************************
******************************************************************************

<<title Internal pick-window generator for SMALLSYS. Do not run>>
<<uicode>>

if type(_insys_) = "U"
  gen_error(;
 "_SYSPICK.TEM is part of the SMALLSYS system. It cannot be run separately.")
endif

private pickbox                     ** the box we're generating a pick for
private dad
private i

**
** LINKs: set up depending on defs found in pickbox slots
**
private picklinks                   ** all links
private plink                       ** temp
private helpl                       ** help link
private displ                       ** display link
private appendl                     ** append link
private editl                       ** edit link
private deletel                     ** delete link
private codename                    ** temp
private codetype
private linkrunner                  ** used in set_next_link()
private link1

**
** privates used in generating pick list code
**
private field1                      ** the first field in window's item row
private dbf1                        ** field1's parent DBF
private firstrow, lastrow           ** 1st and last rows used by picklist
private firstcol, lastcol
private rowdispxpr                  ** the row display expression
private rowdispxpr_Q                ** the row display expression w. quotes
private autoseek                    ** generate autoseek code? flag
private setproc                     ** SET PROC needed? flag
private usedriver                   ** use picklist driver? flag

** get name of dad (calling module(s)/proc(s)
dad = link_dadname(picklink)

** get name,type of this module/proc
codename = link_codename(picklink)
codetype = link_codetype(picklink)

** get actual pickbox object from link line
pickbox = grab_box(link_objname(picklink))

** if we're a proc, set this
if codetype = "PROC"
  active_procfile = file
endif

**
** set up links, if any
**
appendl = ""
editl = ""
deletel = ""
helpl = ""
displ = ""
picklinks = array('C', 32)
linkrunner = array('N',2)
linkrunner[1] = 1
linkrunner[2] = 1
picklinks[1] = set_next_link(pickbox, codename)
for i = 2 to len(picklinks)
  exit when empty(picklinks[i-1])
  switch link_act(picklinks[i-1])
    case "APPEND"
      appendl = picklinks[i-1]
    case "EDIT"
      editl = picklinks[i-1]
    case "DELETE"
      deletel = picklinks[i-1]
    case "HELP"
      helpl = picklinks[i-1]
    case "DISPLAY"
      displ = picklinks[i-1]
  endsw
  picklinks[i] = set_next_link(pickbox, codename)
next

** force inline display link if none specified
if empty(displ)
  displ = digest_link(codename, "DISPLAY {pickbox.name} ~ INLINE", ;
                                "DISPLAY", "INLINE")
endif

** if we're a module but links (just set) have implied a procfile, flag it
if codetype = "MODULE" .and. (.not. empty(active_procfile))
  setproc = .T.                         ** flag set proc needed
endif

** until I find out how to get the length of an array in FoxBASE 2.x,
** only Clipper Summer 87 can use the generic picklist driver
if Summer87()
  usedriver = ask_for_yn(";
    Use generic pick list driver for {codename} (slower but smaller)?")
else
  usedriver = .f.
endif

if usedriver
  add_link_to_sys("PICKDRVR ~ ~ MODULE:{gendir}PICKDRVR.PRG {codename}")
endif

**
** set up pick list privates defined above
**
field1 = first_field_in_box(pickbox)
dbf1 = field1.dbf
firstrow = field1.row
lastrow = last_empty_row_after(pickbox, field1.row, field1.col)
firstcol = pickbox.left + iif(pickbox.outline.type,1,0)
lastcol = pickbox.right - iif(pickbox.outline.type,1,0)
rowdispxpr = build_row_display_xpr(pickbox, firstrow)
rowdispxpr_Q = build_row_display_xpr(pickbox, firstrow, .t.)   && within quotes
autoseek = use_autoseek(pickbox)
**
**


****************************************
*** generate comment header          ***
****************************************

?
? replicate('*',76)
? "**{space(72)}**"

if codetype = "PROC"
  ? banrline("Procedure {link_codename(picklink)}")
else
  ? banrline("{link_codename(picklink)} (file {link_codefile(picklink)})")
endif

if .not. empty(dad)
  ? banrline("Called from {dad}")
else
  ? banrline("Top-level module")
endif

? "**{space(72)}**"
? banrline("Generated from box '{link_objname(picklink)}' in .WW file '{wwfile}'")
? "**{space(72)}**"
? banrline("Pick list into database {dbf1.name}.")
if len(dbf1.indexes) > 0
  ? banrline("Indexed on {dbf1.indexes[1].name} ('{dbf1.indexes[1].expr}')")
endif

if usedriver
  ? banrline("Uses generic driver PICKDRVR.PRG")
endif

link1 = .f.
for i = 1 to len(picklinks)
  exit when empty(picklinks[i])
  if .not. link1
    ? "**{space(72)}**"
    ? banrline("Other actions from this {codetype}:")
    ? "**{space(72)}**"
    link1 = .t.
  endif
  plink = picklinks[i]
  ? banrline("   {link_act(plink)}: {link_codename(plink)} ({link_codetype(plink)})")
next

? "**{space(72)}**"
for i = 1 to len(picklinks)
  exit when empty(picklinks[i])
  if link_codetype(picklinks[i]) = "PROC"
    if active_procfile <> file
      ? banrline("Procedures defined in {active_procfile}")
    else
      ? banrline("Procedures defined in this file.")
    endif
    exit
  endif
next

? replicate('*',76)

if codetype = "PROC"
  ?
  ? "PROCEDURE {link_codename(picklink)}"
endif

?

****************************************
*** end of comment header gen,       ***
*** lots of literal code starts here ***
****************************************

<<enduicode>>
<<if .not. empty(dad)           ** not top system module>>
PARAM retval                        && passback success var
<<else>>
PRIVATE retval
<<endif>>

PRIVATE ok                          && passback var for append and/or delete
PRIVATE t, l, b, r                  && pickbox coordinates
PRIVATE locolor, hicolor            && colors
<<if usedriver>>
PRIVATE hotkeys                     && keys to force driver exit
PRIVATE startrow                    && row offset into list, pass thru driver
<<else>>
PRIVATE currow, thisrow             && row save variables
PRIVATE drows, dcols                && # display rows, # display columns
PRIVATE rec1, recN                  && recno() save variables
PRIVATE saverec, toprec             && ditto
PRIVATE keyhit                         && keyhit holder
PRIVATE redisp, slide               && redisplay flags
PRIVATE trash                       && self-explanatory, haha
 <<if autoseek>>
PRIVATE seekbuf                     && autoseek buffer
 <<endif>>
 <<if Clipper() .or. Fox2()>>
PRIVATE {pop_buf_name(pickbox)}     && screen save buffer
 <<endif>>
<<endif>>

<<if empty(dad)             ** top (first) module>>
 <<env_setup()>>
CLEAR

* global data directories
dbfpath = "{dbfdir}"
indexpath = "{ndxdir}"
 <<init_all_dbfs("dbfpath","indexpath",.t.)>>
<<endif>>
SET DELETED ON                      && for picklist
<<if setproc                ** do a set proc?>>
 <<if Clipper()>>
SET PROC TO {stripdir(striptag(active_procfile))}
 <<else>>
SET PROC TO {active_procfile}
 <<endif>>
<<endif>>

<<uicode>>
** generate commented EXTERNAL line for Clipper
if Clipper()
  private externstart
  externstart = .F.
  for i = 1 to len(picklinks)
    plink = picklinks[i]
    exit when empty(plink)
    if (.not. empty(plink)) .and. ;
       link_codetype(plink) = "MODULE"
      if .not. externstart
        ? "** Uncomment following line to declare modules EXTERNAL (i.e. don't compile"
        ? "** into {striptag(file)}.OBJ, but specify them to the linker)"
        ? "** EXTERNAL "
        externstart = .T.
      else
        ?? ", "
      endif
      ?? link_codename(plink)
    endif
  next
endif
<<enduicode>>

<<if link_codetype(displ) = "INLINE">>
    <<pop_box(pickbox)>>
<<else>>
    <<call_save_screen(pickbox, pop_buf_name(pickbox))>>
DO {link_codename(displ)}
<<endif>>

hicolor = "{field1.color}"
locolor = "{pickbox.contents.color}"
<<if .not. usedriver>>

t = {firstrow}
l = {firstcol}
b = {lastrow}
r = {lastcol}


saverec = recno()                   && in case this was important
GO TOP                              && snag some important recno()s
rec1 = recno()
GO BOTTOM
recN = recno()
GO saverec                          && back to where we started

<<if autoseek>>
seekbuf = ""                        && init seek buffer
<<endif>>
drows = b-t+1                       && number of displayed rows
dcols = r-l+1                       && number of displayed columns
currow = t                          && current row at top of pickbox
redisp = -1                         && initial display, leave hilite at top
slide = 0                           && no initial slide

<<do case>>
  <<case Clipper()>>
SET CURSOR OFF
  <<case Fox2()>>
?? sys(2002)                        && cursor off
<<endcase>>

<<endif>>

<<uicode>>
 if usedriver
   for i = 1 to len(picklinks)-1
     exit when empty(picklinks[i])
   next
   if Clipper()
     ?"DECLARE hotkeys[{i-1}]          && hot key array for driver"
     for i = 1 to len(picklinks)-1
       exit when empty(picklinks[i])
       ?"hotkeys[{i}] = {link_key(picklinks[i])}"
     next
   else
     ?"DIMENSION hotkeys({i-1})          && hot key array for driver"
     for i = 1 to len(picklinks)-1
       exit when empty(picklinks[i])
       ?"STORE {link_key(picklinks[i])} TO hotkeys({i})"
     next
   endif
 endif
<<enduicode>>

SET COLOR TO &locolor, &hicolor
ok = .F.                            && initialize passback var
startrow = 0                        && first startrow is 0 (top of list)

DO WHILE .T.
<<if usedriver>>

  keyhit = 0
  DO PICKDRVR WITH ;
      {firstrow}, {firstcol}, {lastrow}, {lastcol}, ;
      '{rowdispxpr_Q}', ;           && enclosed in quotes
      "{pickbox.contents.color}", "{field1.color}", ;
      {iif(autoseek,".T.", ".F.")}, ;
      hotkeys, ;
      keyhit, ;
      startrow
<<else>>

  DO CASE                           && display stuff from flags set below

<<do case   ** hardware scroll, if flavor supports it>>
  <<case Clipper()>>
    CASE slide <> 0                 && slide 1 row up or down
      scroll(t, l, b, r, slide)     && do hardware scroll
      currow = iif(slide <0, t, b)  && set currow for hilite below
      slide = 0                     && unset slide
  <<case Fox2()>>
    CASE slide <> 0                 && slide 1 row up or down
      SCROLL t, l, b, r, slide      && do hardware scroll
      currow = iif(slide <0, t, b)  && set currow for hilite below
      slide = 0                     && unset slide
<<endcase>>

    CASE redisp < 0                 && redisplay, leaving current rec at top
      toprec = recno()              && save top rec
      thisrow = t                   && display rows from t to b
      DO WHILE thisrow <= b .AND. .NOT. eof()
        sprint(thisrow, l, ;
          {rowdispxpr} )
        SKIP
        thisrow = thisrow +1
      ENDDO
      DO WHILE thisrow <= b         && in case empty rows after eof()
        sprint(thisrow, l, space(dcols) )
        thisrow = thisrow +1
      ENDDO
      GO toprec                     && go back to top
      thisrow = redisp
      currow = t                    && set currow for hilite later
      DO WHILE thisrow < -1
        SKIP
        currow = currow +1
        thisrow = thisrow +1
      ENDDO
      redisp = 0                    && unset redisp

    CASE redisp > 0                 && redisplay, leaving current rec at bot
      thisrow = t                   && display rows from t to b
      DO WHILE .NOT. eof() .AND. thisrow <= b
        sprint(thisrow, l, ;
          {rowdispxpr} )
        SKIP
        thisrow = thisrow +1
      ENDDO
      DO WHILE thisrow <= b         && in case empty rows after eof()
        sprint(thisrow, l, space(dcols) )
        thisrow = thisrow +1
      ENDDO
      thisrow = thisrow -1
      SKIP -1
      DO WHILE redisp > 1
        thisrow = thisrow -1           && set currow for hilite, below
        redisp = redisp -1
      ENDDO
      currow = thisrow
      redisp = 0

  ENDCASE

                                    
  sprint(currow, l, ;
    {rowdispxpr}, hicolor )         && hilite current item

  keyhit = inkey(0)                 && get keyhit
  CLEAR TYPEAHEAD                   && need all the speed we can get

<<endif>>

  DO CASE                           && key hit action loop

<<uicode>>
** the links
for i = 1 to len(picklinks)
  plink = picklinks[i]
  exit when empty(plink)
  switch link_act(plink)
    case "EDIT"             ** edit link
     <<enduicode>>
    CASE keyhit = {link_key(plink)}
      DO {link_codename(plink)} WITH ok && edit current record
      SET COLOR TO &locolor, &hicolor   && just in case
     <<if .not. usedriver>>
      IF ok
        SKIP -(currow-t)
        redisp = -1-(currow-t)          && redisp
      ENDIF
     <<endif>>

     <<uicode>>
    case "APPEND"           ** append link
     <<enduicode>>
    CASE keyhit = {link_key(plink)}
      DO {link_codename(plink)} WITH ok
      SET COLOR TO &locolor, &hicolor   && just in case
     <<if .not. usedriver>>
      IF ok                             && we really appended
        SKIP -(currow-t)
        redisp = -1-(currow-t)          && redisp
      ENDIF
     <<endif>>

     <<uicode>>
    case "DELETE"           ** delete link
     <<enduicode>>
    CASE keyhit = {link_key(plink)}
     <<if link_codetype(plink) = "INLINE" ** inline, generate it here>>
      <<q_indent = 6>>
      <<gen_confirm(plink)>>
      <<q_indent = 0>>
      hicolor = "{field1.color}"
      locolor = "{pickbox.contents.color}"
     <<else                                 ** proc/module, just call it here>>
      DO {link_codename(plink)} WITH ok   && delete current record
     <<endif>>
     <<if .not. usedriver>>
      IF ok                         && we actually deleted it
        SKIP -(currow-t)
        redisp = -1-(currow-t)          && redisp
      ENDIF
     <<endif>>
      SET COLOR TO &locolor, &hicolor   && just in case

     <<uicode>>

    case "HELP"             ** help link
     <<enduicode>>
    CASE keyhit = {link_key(plink)}
     <<if link_codetype(plink) = "INLINE"   ** inline, generate it here>>
      <<q_indent = 6>>
      <<gen_disphit(plink)>>
      <<q_indent = 0>>
      hicolor = "{field1.color}"
      locolor = "{pickbox.contents.color}"
      SET COLOR TO &locolor, &hicolor   && just in case
     <<else                                 ** proc/module, just call it here>>
      DO {link_codename(plink)}     && pop help
      SET COLOR TO &locolor, &hicolor   && just in case
     <<endif>>

     <<uicode>>

    otherwise                       ** some other kinda link, menu prolly
     <<enduicode>>
    CASE keyhit = {link_key(plink)}
      DO {link_codename(plink)} WITH ok
      SET COLOR TO &locolor, &hicolor   && just in case
     <<if .not. usedriver>>
      IF ok                             && we really appended
        SKIP -(currow-t)
        redisp = -1-(currow-t)          && redisp
      ENDIF
     <<endif>>
     <<uicode>>

  endsw
next
<<enduicode>>

    CASE keyhit = 13                   && car. ret. -- recno() is already set
      retval = .T.
      EXIT

    CASE keyhit = 27                   && escape
      retval = .F.
      EXIT
<<if .not. usedriver>>

    CASE keyhit = 5                    && up
      IF recno() = rec1             && at top?
        ?? chr(7)
      ELSE
        && unhilite current selection
        sprint(currow, l, ;
          {rowdispxpr}, locolor)
        SKIP -1                     && decrement selected record
        IF currow > t               && not the top displayed row
          currow = currow - 1       && just decrement
        ELSE                        && top displayed row
<<if Clipper() .or. Fox2()  ** hardware scroll if possible>>
          slide = -1                && set slide flag
<<else                      ** otherwise plain old redisplay>>
          redisp = -1               && redisplay, 1 up from current
<<endif                     ** end of hardware scroll>>
        ENDIF
      ENDIF

    CASE keyhit = 24                   && down
      IF recno() = recN             && at bottom of file?
        ?? chr(7)
      ELSE
        && unhilite current selection
        sprint(currow, l, ;
          {rowdispxpr}, locolor )
        SKIP                        && increment selected record
        IF currow < b               && not the last displayed row
          currow = currow + 1       && just increment
        ELSE                        && bottom displayed row
<<if Clipper() .or. Fox2()  ** hardware scroll if possible>>
          slide = 1                 && set slide flag
<<else                      ** otherwise plain old redisplay>>
          SKIP 2-drows
          redisp = 1                && redisplay, 1 up from current
<<endif                     ** end of hardware scroll>>
        ENDIF
      ENDIF

    CASE keyhit = 18                   && page up
      SKIP t - currow - drows       && skip to top of prec page
      IF bof()                      && beep if at top
        ?? chr(7)
      ENDIF
      redisp = -1                   && redisp, leaving hilite at top

    CASE keyhit = 3                    && page down
      SKIP t -currow +(2*drows) -1  && skip to there we want bot. of new page
      IF eof()                      && ran out of file
        ?? chr(7)
        SKIP -drows                 && skip to 1 page above eof()
        redisp = 1                  && redisp, leaving hilite at bottom
      ELSE                          && ok
        SKIP 1-drows                && skip to 1 page above eof()
        redisp = -1                 && redisp, leaving hilite at top
      ENDIF

    CASE keyhit = 1                    && home, easy
      GO TOP
      redisp = -1

    CASE keyhit = 6                    && end, pretty easy
      GO BOTTOM
      SKIP 1-drows
      redisp = 1

 <<if autoseek>>
    CASE keyhit > 32 .AND. keyhit < 127   && printable char, try seeking
      saverec = recno()             && save current record pos
                                    && add letter to seek buffer
      seekbuf = seekbuf + upper(chr(keyhit))
      SEEK seekbuf                  && give it a shot
      IF eof()                      && naah, beep & retreat
        ?? chr(7)
        seekbuf = substr(seekbuf,1,len(seekbuf)-1)
        GO saverec
      ELSE
        SKIP -(currow-t)
        redisp = -1-(currow-t)          && redisp
      ENDIF

    CASE keyhit = 8                     && backspace
<<if Clipper()>>
      IF empty(seekbuf)                 && seek buffer's empty
<<else>>
      IF len(trim(seekbuf)) = 0         && seek buffer's empty
<<endif>>
        ?? chr(7)
        LOOP
      ENDIF
      seekbuf = substr(seekbuf,1,len(seekbuf)-1)
      SEEK seekbuf                  && we know it's here
      redisp = -1

 <<endif>>
<<endif>>
  ENDCASE

ENDDO

<<do case>>
  <<case Clipper()>>
SET CURSOR ON
  <<case Fox2()>>
?? sys(2002,1)                      && cursor on
<<endcase>>

<<if Clipper() .or. Fox2()>>
 <<unpop_box(pickbox)>>
<<endif>>

<<if .not. empty(deletel)   ** we turned delete on, turn it off>>
SET DELETED OFF
<<endif>>
<<if empty(dad)                     ** top module, shut things off>>
CLOSE DATABASES                     && shut everything down
<<endif>>

<<if setproc>>
 <<if active_procfile <> file>>
SET PROC TO
 <<endif>>
<<endif>>

RETURN

<<uicode>>

**
** reset active_procfile
**
if setproc                  ** if we opened the proc file in here, close it
  active_procfile = ""
endif


<<enduicode>>